home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / CNV.R next >
Encoding:
Text File  |  1992-02-10  |  24.9 KB  |  1,112 lines
  1. /*
  2.  * cnv.r -- Conversion routines:
  3.  *
  4.  * cnv_c_dbl, cnv_c_int, cnv_c_str, cnv_cset, cnv_ec_int,
  5.  * cnv_eint, cnv_int, cnv_real, cnv_str, cnv_tcset, cnv_tstr, deref
  6.  * strprc, bi_strprc
  7.  *
  8.  * Service routines: itos, ston, radix, cvpos
  9.  *
  10.  * Philosophy: certain redundancy is present which could be avoided,
  11.  * and nested conversion calls are avoided due to the importance of
  12.  * minimizing these routines' costs.
  13.  *
  14.  * Assumed: the C compiler must handle assignments of C integers to
  15.  * C double variables and vice-versa.  Hopefully production C compilers
  16.  * have managed to eliminate bugs related to these assignments.
  17.  */
  18.  
  19. #if !EBCDIC
  20. #define tonum(c)    (isdigit(c) ? (c)-'0' : 10+(((c)|(040))-'a'))
  21. #endif                    /* EBCDIC */
  22.  
  23. /*
  24.  * Prototypes for static functions.
  25.  */
  26. hidden novalue cstos Params((int *cs, dptr dp, char *s));
  27. hidden novalue itos  Params((C_integer num, dptr dp, char *s));
  28. hidden int     ston  Params((dptr sp, union numeric *result));
  29.  
  30. /*
  31.  * cnv_c_dbl - cnv:C_double(*s, *d), convert a value directly into a C double
  32.  */
  33. int cnv_c_dbl(s, d)
  34. dptr s;
  35. double *d;
  36.    {
  37. #ifdef LargeInts
  38.    tended    /* need to be tended if ston allocates largeint blocks */
  39. #endif                    /* LargeInts */
  40.      struct descrip result, cnvstr;
  41.  
  42.    union numeric numrc;
  43.  
  44.    type_case *s of {
  45.       real: {
  46.          GetReal(s, *d);
  47.          return 1;
  48.          }
  49.       integer: {
  50. #ifdef LargeInts
  51.          if (Type(*s) == T_Lrgint)
  52.             *d = bigtoreal(s);
  53.          else
  54. #endif                    /* LargeInts */
  55.             *d = IntVal(*s);
  56.          return 1;
  57.          }
  58.       string: {
  59.          /* fall through */
  60.          }
  61.       cset: {
  62.         cnv:tmp_string(*s, cnvstr);
  63.         s = &cnvstr;
  64.         }
  65.       default:
  66.         return 0;
  67.       }
  68.  
  69.    /*
  70.     * s is now an string.
  71.     */
  72.    switch( ston(s, &numrc) ) {
  73.       case T_Integer:
  74.          *d = numrc.integer;
  75.          return 1;
  76. #ifdef LargeInts
  77.       case T_Lrgint:
  78.          result.dword = D_Lrgint;
  79.      BlkLoc(result) = (union block *)numrc.big;
  80.          *d = bigtoreal(&result);
  81.          return 1;
  82. #endif                    /* LargeInts */
  83.       case T_Real:
  84.          *d = numrc.real;
  85.          return 1;
  86.       default:
  87.          return 0;
  88.       }
  89.   }
  90.  
  91. /*
  92.  * cnv_c_int - cnv:C_integer(*s, *d), convert a value directly into a C_integer
  93.  */
  94. int cnv_c_int(s, d)
  95. dptr s;
  96. C_integer *d;
  97.    {
  98. #ifdef LargeInts
  99.    tended  /* tended since ston now allocates blocks */
  100. #endif                        /* LargeInts */
  101.       struct descrip cnvstr, result;            /* not tended */
  102.    union numeric numrc;
  103.  
  104.    type_case *s of {
  105.       integer: {
  106. #ifdef LargeInts
  107.          if (Type(*s) == T_Lrgint)
  108.             return 0;
  109. #endif                    /* LargeInts */
  110.          *d = IntVal(*s);
  111.          return 1;
  112.          }
  113.       real: {
  114.          double dbl;
  115.          GetReal(s,dbl);
  116.          if (dbl > MaxLong || dbl < MinLong)
  117.             return 0;
  118.          *d = dbl;
  119.          return 1;
  120.          }
  121.       string: {
  122.          /* fall through */
  123.          }
  124.       cset: {
  125.         cnv:tmp_string(*s, cnvstr);
  126.         s = &cnvstr;
  127.         }
  128.       default:
  129.         return 0;
  130.       }
  131.  
  132.    /*
  133.     * s is now a string.
  134.     */
  135.    switch( ston(s, &numrc) ) {
  136.       case T_Integer: {
  137.          *d = numrc.integer;
  138.          return 1;
  139.      }
  140.       case T_Real: {
  141.          double dbl = numrc.real;
  142.          if (dbl > MaxLong || dbl < MinLong)
  143.             return 0;
  144.          *d = dbl;
  145.          return 1;
  146.          }
  147.       default:
  148.          return 0;
  149.       }
  150.    }
  151.  
  152. /*
  153.  * cnv_c_str - cnv:C_string(*s, *d), convert a value into a C (and Icon) string
  154.  */
  155. int cnv_c_str(s, d)
  156. dptr s;
  157. dptr d;
  158.    {
  159.    /*
  160.     * Get the string to the end of the string region and append a '\0'.
  161.     */
  162.  
  163. #ifdef MultiRegion
  164.    if (!is:string(*s)) {
  165.       if (!cnv:string(*s,*d)) {
  166.          return 0;
  167.          }
  168.       }
  169.    else *d = *s;
  170.  
  171.    /*
  172.     * See if the end of d is already at the end of the string region
  173.     * and (in MultiRegions) there is room for one more byte.
  174.     */
  175.    if ((StrLoc(*d) + StrLen(*d) == strfree) && (strfree != strend)) {
  176.       Protect(alcstr("\0", 1), fatalerr(0,NULL));
  177.       ++StrLen(*d);
  178.       }
  179.    else {
  180.       register word slen = StrLen(*d);
  181.       register char *sp, *dp;
  182.       Protect(dp = alcstr(NULL,slen+1), fatalerr(0,NULL));
  183.       StrLen(*d) = StrLen(*d)+1;
  184.       sp = StrLoc(*d);
  185.       StrLoc(*d) = dp;
  186.       while (slen-- > 0)
  187.          *dp++ = *sp++;
  188.       *dp = '\0';
  189.       }
  190.  
  191. #else                        /* MultiRegion */
  192.  
  193.    if (is:string(*s)) {
  194.      /*
  195.        * See if the end of s is already at the end of the string region.
  196.        */
  197.       if (StrLoc(*s) + StrLen(*s) == strfree)
  198.          *d = *s;
  199.       else {
  200.          Protect(StrLoc(*d) = alcstr(StrLoc(*s),StrLen(*s)), fatalerr(0,NULL));
  201.          StrLen(*d) = StrLen(*s);
  202.          }
  203.       }
  204.    else if (!cnv:string(*s, *d)) {
  205.       return 0;
  206.       }
  207.  
  208.    Protect(alcstr("\0", 1), fatalerr(0,NULL));
  209.    ++StrLen(*d);
  210.  
  211. #endif                        /* MultiRegion */
  212.  
  213.  
  214.    return 1;
  215.    }
  216.  
  217. /*
  218.  * cnv_cset - cnv:cset(*s, *d), convert to a cset
  219.  */
  220. int cnv_cset(s, d)
  221. dptr s, d;
  222.    {
  223.    tended struct descrip str;
  224.    register C_integer l;
  225.    register char *s1;        /* does not need to be tended */
  226.  
  227.    if (is:cset(*s)) {
  228.       *d = *s;
  229.       return 1;
  230.       }
  231.    /*
  232.     * convert to a string and then add its contents to the cset
  233.     */
  234.    if (cnv:tmp_string(*s, str)) {
  235.       d->dword = D_Cset;
  236.       Protect(BlkLoc(*d) = (union block *)alccset(), fatalerr(0,NULL));
  237.       s1 = StrLoc(str);
  238.       l = StrLen(str);
  239.       while(l--) {
  240.          Setb(*s1, *d);
  241.      s1++;
  242.          }
  243.       return 1;
  244.       }
  245.    else {
  246.       return 0;
  247.       }
  248.   }
  249.  
  250. /*
  251.  * cnv_ec_int - cnv:(exact)C_integer(*s, *d), convert to an exact C integer
  252.  */
  253. int cnv_ec_int(s, d)
  254. dptr s;
  255. C_integer *d;
  256.    {
  257. #ifdef LargeInts
  258.    tended  /* tended since ston now allocates blocks */
  259. #endif                        /* LargeInts */
  260.       struct descrip cnvstr;            /* not tended */
  261.    union numeric numrc;
  262.  
  263.    type_case *s of {
  264.       integer: {
  265. #ifdef LargeInts
  266.          if (Type(*s) == T_Lrgint)
  267.             return 0;
  268. #endif                    /* LargeInts */
  269.          *d = IntVal(*s);
  270.          return 1;
  271.          }
  272.       string: {
  273.          /* fall through */
  274.          }
  275.       cset: {
  276.         cnv:tmp_string(*s, cnvstr);
  277.         s = &cnvstr;
  278.         }
  279.       default:
  280.         return 0;
  281.       }
  282.  
  283.    /*
  284.     * s is now a string.
  285.     */
  286.    if (ston(s, &numrc) == T_Integer) {
  287.       *d = numrc.integer;
  288.       return 1;
  289.       }
  290.    else
  291.       return 0;
  292.    }
  293.  
  294. /*
  295.  * cnv_eint - cnv:(exact)integer(*s, *d), convert to an exact integer
  296.  */
  297. int cnv_eint(s, d)
  298. dptr s, d;
  299.    {
  300. #ifdef LargeInts
  301.    tended  /* tended since ston now allocates blocks */
  302. #endif                        /* LargeInts */
  303.       struct descrip cnvstr;            /* not tended */
  304.    union numeric numrc;
  305.    int status;
  306.  
  307.    type_case *s of {
  308.       integer: {
  309.          *d = *s;
  310.          return 1;
  311.          }
  312.       string: {
  313.          /* fall through */
  314.          }
  315.       cset: {
  316.         cnv:tmp_string(*s, cnvstr);
  317.         s = &cnvstr;
  318.         }
  319.       default:
  320.         return 0;
  321.       }
  322.  
  323.    /*
  324.     * s is now a string.
  325.     */
  326.    switch (ston(s, &numrc)) {
  327.       case T_Integer:
  328.          MakeInt(numrc.integer, d);
  329.      return 1;
  330. #ifdef LargeInts
  331.       case T_Lrgint:
  332.          d->dword = D_Lrgint;
  333.      BlkLoc(*d) = (union block *)numrc.big;
  334.          return 1;
  335. #endif                /* LargeInts */
  336.       default:
  337.          return 0;
  338.       }
  339.    }
  340.  
  341. /*
  342.  * cnv_int - cnv:integer(*s, *d), convert to integer
  343.  */
  344. int cnv_int(s, d)
  345. dptr s, d;
  346.    {
  347. #ifdef LargeInts
  348.    tended   /* tended since ston now allocates blocks */
  349. #endif                        /* LargeInts */
  350.       struct descrip cnvstr;            /* not tended */
  351.    union numeric numrc;
  352.    type_case *s of {
  353.       integer: {
  354.          *d = *s;
  355.          return 1;
  356.          }
  357.       real: {
  358.          double dbl;
  359.          GetReal(s,dbl);
  360.          if (dbl > MaxLong || dbl < MinLong) {
  361. #ifdef LargeInts
  362.             if (realtobig(s, d) == Succeeded)
  363.                return 1;
  364.             else
  365.                return 0;
  366. #else                    /* LargeInts */
  367.             return 0;
  368. #endif                    /* LargeInts */
  369.         }
  370.          MakeInt((word)dbl,d);
  371.          return 1;
  372.          }
  373.       string: {
  374.          /* fall through */
  375.          }
  376.       cset: {
  377.         cnv:tmp_string(*s, cnvstr);
  378.         s = &cnvstr;
  379.         }
  380.       default:
  381.         return 0;
  382.       }
  383.  
  384.    /*
  385.     * s is now a string.
  386.     */
  387.    switch( ston(s, &numrc) ) {
  388. #ifdef LargeInts
  389.       case T_Lrgint:
  390.          d->dword = D_Lrgint;
  391.      BlkLoc(*d) = (union block *)numrc.big;
  392.      return 1;
  393. #endif                    /* LargeInts */
  394.       case T_Integer:
  395.          MakeInt(numrc.integer,d);
  396.          return 1;
  397.       case T_Real: {
  398.          double dbl = numrc.real;
  399.          if (dbl > MaxLong || dbl < MinLong) {
  400. #ifdef LargeInts
  401.             if (realtobig(s, d) == Succeeded)
  402.                return 1;
  403.             else
  404.                return 0;
  405. #else                    /* LargeInts */
  406.             return 0;
  407. #endif                    /* LargeInts */
  408.         }
  409.          MakeInt((word)dbl,d);
  410.          return 1;
  411.          }
  412.       default:
  413.          return 0;
  414.       }
  415.    }
  416.  
  417. /*
  418.  * cnv_real - cnv:real(*s, *d), convert to real
  419.  */
  420. int cnv_real(s, d)
  421. dptr s, d;
  422.    {
  423.    double dbl;
  424.    if (cnv:C_double(*s, dbl)) {
  425.       Protect(BlkLoc(*d) = (union block *)alcreal(dbl), fatalerr(0,NULL));
  426.       d->dword = D_Real;
  427.       return 1;
  428.       }
  429.    else
  430.       return 0;
  431.    }
  432.  
  433. /*
  434.  * cnv_str - cnv:string(*s, *d), convert to a string
  435.  */
  436. int cnv_str(s, d)
  437. dptr s, d;
  438.    {
  439.    char sbuf[MaxCvtLen];
  440.  
  441.    type_case *s of {
  442.       string: {
  443.          *d = *s;
  444.          return 1;
  445.          }
  446.       integer: {
  447. #ifdef LargeInts
  448.          if (Type(*s) == T_Lrgint) {
  449.             word slen;
  450.             word dlen;
  451.  
  452.             slen = (BlkLoc(*s)->bignumblk.lsd - BlkLoc(*s)->bignumblk.msd +1);
  453.             dlen = slen * NB * 0.3010299956639812;    /* 1 / log2(10) */
  454.         bigtos(s,d);
  455.         }
  456.          else
  457. #endif                    /* LargeInts */
  458.          itos(IntVal(*s), d, sbuf);
  459.      }
  460.       real: {
  461.          double res;
  462.          GetReal(s, res);
  463.          rtos(res, d, sbuf);
  464.          }
  465.       cset:
  466.          cstos(BlkLoc(*s)->cset.bits, d, sbuf);
  467.       default:
  468.          return 0;
  469.       }
  470.    Protect(StrLoc(*d) = alcstr(StrLoc(*d), StrLen(*d)), fatalerr(0,NULL));
  471.    return 1;
  472.    }
  473.  
  474. /*
  475.  * cnv_tcset - cnv:tmp_cset(*s, *d), convert to a temporary cset
  476.  */
  477. int cnv_tcset(cbuf, s, d)
  478. struct b_cset *cbuf;
  479. dptr s, d;
  480.    {
  481.    struct descrip tmpstr;
  482.    register char *s1;
  483.    C_integer l;
  484.    if (is:cset(*s)) {
  485.       *d = *s;
  486.       return 1;
  487.       }
  488.    if (cnv:tmp_string(*s,tmpstr)) {
  489.       for (l = 0; l < CsetSize; l++) 
  490.           cbuf->bits[l] = 0;
  491.       d->dword = D_Cset;
  492.       BlkLoc(*d) = (union block *)cbuf;
  493.       s1 = StrLoc(tmpstr);
  494.       l = StrLen(tmpstr);
  495.       while(l--) {
  496.          Setb(*s1, *d);
  497.      s1++;
  498.          }
  499.       return 1;
  500.       }
  501.    else {
  502.       return 0;
  503.       }
  504.    }
  505.  
  506. /*
  507.  * cnv_tstr - cnv:tmp_string(*s, *d), convert to a temporary string
  508.  */
  509. int cnv_tstr(sbuf, s, d)
  510. char *sbuf;
  511. dptr s;
  512. dptr d;
  513.    {
  514.    type_case *s of {
  515.       string:
  516.          *d = *s;
  517.       integer: {
  518. #ifdef LargeInts
  519.          if (Type(*s) == T_Lrgint) {
  520.             word slen;
  521.             word dlen;
  522.  
  523.             slen = (BlkLoc(*s)->bignumblk.lsd - BlkLoc(*s)->bignumblk.msd +1);
  524.             dlen = slen * NB * 0.3010299956639812;    /* 1 / log2(10) */
  525.         bigtos(s,d);
  526.         }
  527.          else
  528. #endif                    /* LargeInts */
  529.          itos(IntVal(*s), d, sbuf);
  530.      }
  531.       real: {
  532.          double res;
  533.          GetReal(s, res);
  534.          rtos(res, d, sbuf);
  535.          }
  536.       cset:
  537.          cstos(BlkLoc(*s)->cset.bits, d, sbuf);
  538.       default:
  539.          return 0;
  540.       }
  541.    return 1;
  542.    }
  543.  
  544. /*
  545.  * deref - dereference a descriptor.
  546.  */
  547. novalue deref(s, d)
  548. dptr s, d;
  549.    {
  550.    /*
  551.     * no allocation is done, so nothing need be tended.
  552.     */
  553.    register union block *bp;
  554.    struct descrip v;
  555.    register union block **ep;
  556.    int res;
  557.  
  558.    if (!is:variable(*s)) {
  559.       *d = *s;
  560.       }
  561.    else type_case *s of {
  562.       tvsubs: {
  563.          /*
  564.           * A substring trapped variable is being dereferenced.
  565.           *  Point bp to the trapped variable block and v to
  566.           *  the string.
  567.           */
  568.          bp = BlkLoc(*s);
  569.          deref(&bp->tvsubs.ssvar, &v);
  570.          if (!is:string(v))
  571.             fatalerr(103, &v);
  572.          if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(v))
  573.             fatalerr(205, NULL);
  574.          /*
  575.           * Make a descriptor for the substring by getting the
  576.           *  length and pointing into the string.
  577.           */
  578.          StrLen(*d) = bp->tvsubs.sslen;
  579.          StrLoc(*d) = StrLoc(v) + bp->tvsubs.sspos - 1;
  580.         }
  581.  
  582.       tvtbl: {
  583.          bp = BlkLoc(*s);
  584.          if (bp->tvtbl.title == T_Telem) {
  585.             /*
  586.              * The tvtbl has been converted to a telem and is
  587.              *  in the table.  Replace the descriptor pointed to
  588.              *  by d with the value of the element.
  589.              */
  590.              *d = bp->telem.tval;
  591.              }
  592.          else {
  593.         /*
  594.          * Look up the element in the table.
  595.          */
  596.         ep = memb(bp->tvtbl.clink,&bp->tvtbl.tref,bp->tvtbl.hashnum,&res);
  597.             if (res == 1)
  598.            *d = (*ep)->telem.tval;            /* found; use value */
  599.             else
  600.                *d = bp->tvtbl.clink->table.defvalue;    /* nope; use default */
  601.             }
  602.         }
  603.  
  604.       kywdint:
  605.       kywdpos:
  606.       kywdsubj:
  607.          *d = *VarLoc(*s);
  608.  
  609.       default:
  610.          /*
  611.           * An ordinary variable is being dereferenced.
  612.           */
  613.          *d = *(dptr)((word *)VarLoc(*s) + Offset(*s));
  614.       }
  615.    }
  616.  
  617. /*
  618.  * dp_pnmcmp - do a string comparison of a descriptor to the procedure 
  619.  *   name in a pstrnm struct; used in call to qsearch().
  620.  */
  621. int dp_pnmcmp(pne,dp)
  622. struct pstrnm *pne;
  623. struct descrip *dp;
  624. {
  625.    struct descrip d;
  626.    StrLen(d) = strlen(pne->pstrep);
  627.    StrLoc(d) = pne->pstrep;
  628.    return lexcmp(&d,dp);
  629. }
  630.  
  631. /*
  632.  * bi_strprc - convert a string to a (built-in) function or operator.
  633.  */
  634. struct b_proc *bi_strprc(s, arity)
  635. dptr s;
  636. C_integer arity;
  637.    {
  638.    C_integer i;
  639.    char *fnc;
  640.    struct pstrnm *pp;
  641.  
  642.    /*
  643.     * See if the string represents an operator. In this case the arity
  644.     *  of the operator must match the one given.
  645.     */
  646.    for (i = 0; i < op_tbl_sz; ++i)
  647.       if (eq(s, &op_tbl[i].pname) && arity == op_tbl[i].nparam)
  648.          return &op_tbl[i];
  649.  
  650. #if !COMPILER
  651.    if (!is:string(*s))
  652.       return NULL;
  653.    /*
  654.     * See if the string represents a built-in function that we didn't catch
  655.     * in the globals array.
  656.     */
  657.    pp = (struct pstrnm *)qsearch((char *)s,(char *)pntab,pnsize,
  658.                  sizeof(struct pstrnm),dp_pnmcmp);
  659.    if (pp!=NULL)
  660.       return (struct b_proc *)pp->pblock;
  661. #endif                    /* !COMPILER */
  662.  
  663.    return NULL;
  664.    }
  665.  
  666. /*
  667.  * strprc - convert a string to a procedure.
  668.  */
  669. struct b_proc *strprc(s, arity)
  670. dptr s;
  671. C_integer arity;
  672.    {
  673.    C_integer i;
  674.    char *fnc;
  675.  
  676.    /*
  677.     * See if the string is the name of a global variable.
  678.     */
  679.    for (i = 0; i < n_globals; ++i)
  680.       if (eq(s, &gnames[i]))
  681.          if (is:procedure(globals[i]))
  682.             return (struct b_proc *)BlkLoc(globals[i]);
  683.          else
  684.             return NULL;
  685.  
  686.    return bi_strprc(s,arity);
  687.    }
  688.  
  689. /*
  690.  * Service routines
  691.  */
  692.  
  693. /*
  694.  * itos - convert the integer num into a string using s as a buffer and
  695.  *  making q a descriptor for the resulting string.
  696.  */
  697.  
  698. static novalue itos(num, dp, s)
  699. C_integer num;
  700. dptr dp;
  701. char *s;
  702.    {
  703.    register char *p;
  704.    long ival;
  705.    static char *maxneg = MaxNegInt;
  706.  
  707.    p = s + MaxCvtLen - 1;
  708.    ival = num;
  709.  
  710.    *p = '\0';
  711.    if (num >= 0L)
  712.       do {
  713.      *--p = ival % 10L + '0';
  714.      ival /= 10L;
  715.      } while (ival != 0L);
  716.    else {
  717.       if (ival == -ival) {      /* max negative value */
  718.      p -= strlen (maxneg);
  719.      sprintf (p, "%s", maxneg);
  720.          }
  721.       else {
  722.     ival = -ival;
  723.     do {
  724.        *--p = '0' + (ival % 10L);
  725.        ival /= 10L;
  726.        } while (ival != 0L);
  727.     *--p = '-';
  728.     }
  729.       }
  730.  
  731.    StrLen(*dp) = s + MaxCvtLen - 1 - p;
  732.    StrLoc(*dp) = p;
  733.    }
  734.  
  735.  
  736. /*
  737.  * ston - convert a string to a numeric quantity if possible.
  738.  * Returns a typecode or CvtFail.  Its answer is in the dptr,
  739.  * unless its a double, in which case its in the union numeric
  740.  * (we do this to avoid allocating a block for a real
  741.  * that will later be used directly as a C_double).
  742.  */
  743. static int ston(sp, result)
  744. dptr sp;
  745. union numeric *result;
  746.    {
  747.    register char *s = StrLoc(*sp), *end_s;
  748.    register int c;
  749.    int realflag = 0;    /* indicates a real number */
  750.    char msign = '+';    /* sign of mantissa */
  751.    char esign = '+';    /* sign of exponent */
  752.    double mantissa = 0; /* scaled mantissa with no fractional part */
  753.    long lresult = 0;    /* integer result */
  754.    int scale = 0;    /* number of decimal places to shift mantissa */
  755.    int digits = 0;    /* total number of digits seen */
  756.    int sdigits = 0;    /* number of significant digits seen */
  757.    int exponent = 0;    /* exponent part of real number */
  758.    double fiveto;    /* holds 5^scale */
  759.    double power;    /* holds successive squares of 5 to compute fiveto */
  760.    int err_no;
  761.    char *ssave;         /* holds original ptr for bigradix */
  762.  
  763.    if (StrLen(*sp) == 0)
  764.       return CvtFail;
  765.    end_s = s + StrLen(*sp);
  766.    c = *s++;
  767.  
  768.    /*
  769.     * Skip leading white space.
  770.     */
  771.    while (isspace(c))
  772.       if (s < end_s)
  773.          c = *s++;
  774.       else
  775.          return CvtFail;
  776.  
  777.    /*
  778.     * Check for sign.
  779.     */
  780.    if (c == '+' || c == '-') {
  781.       msign = c;
  782.       c = (s < end_s) ? *s++ : ' ';
  783.       }
  784.  
  785.    ssave = s - 1;   /* set pointer to beginning of digits in case it's needed */
  786.  
  787.    /*
  788.     * Get integer part of mantissa.
  789.     */
  790.    while (isdigit(c)) {
  791.       digits++;
  792.       if (mantissa < Big) {
  793.      mantissa = mantissa * 10 + (c - '0');
  794.          lresult = lresult * 10 + (c - '0');
  795.      if (mantissa > 0.0)
  796.         sdigits++;
  797.      }
  798.       else
  799.      scale++;
  800.       c = (s < end_s) ? *s++ : ' ';
  801.       }
  802.  
  803.    /*
  804.     * Check for based integer.
  805.     */
  806.    if (c == 'r' || c == 'R') {
  807.       int rv;
  808. #ifdef LargeInts
  809.       rv = bigradix((int)msign, (int)mantissa, s, end_s, result);
  810.       if (rv == Error)
  811.          fatalerr(0, NULL);
  812. #else                    /* LargeInts */
  813.       rv = radix((int)msign, (int)mantissa, s, end_s, result);
  814. #endif                    /* LargeInts */
  815.       return rv;
  816.       }
  817.  
  818.    /*
  819.     * Get fractional part of mantissa.
  820.     */
  821.    if (c == '.') {
  822.       realflag++;
  823.       c = (s < end_s) ? *s++ : ' ';
  824.       while (isdigit(c)) {
  825.      digits++;
  826.      if (mantissa < Big) {
  827.         mantissa = mantissa * 10 + (c - '0');
  828.         lresult = lresult * 10 + (c - '0');
  829.         scale--;
  830.         if (mantissa > 0.0)
  831.            sdigits++;
  832.         }
  833.          c = (s < end_s) ? *s++ : ' ';
  834.      }
  835.       }
  836.  
  837.    /*
  838.     * Check that at least one digit has been seen so far.
  839.     */
  840.    if (digits == 0)
  841.       return CvtFail;
  842.  
  843.    /*
  844.     * Get exponent part.
  845.     */
  846.    if (c == 'e' || c == 'E') {
  847.       realflag++;
  848.       c = (s < end_s) ? *s++ : ' ';
  849.       if (c == '+' || c == '-') {
  850.      esign = c;
  851.          c = (s < end_s) ? *s++ : ' ';
  852.      }
  853.       if (!isdigit(c))
  854.      return CvtFail;
  855.       while (isdigit(c)) {
  856.      exponent = exponent * 10 + (c - '0');
  857.          c = (s < end_s) ? *s++ : ' ';
  858.      }
  859.       scale += (esign == '+') ? exponent : -exponent;
  860.       }
  861.  
  862.    /*
  863.     * Skip trailing white space and make sure there is nothing else left
  864.     *  in the string. Note, if we have already reached end-of-string,
  865.     *  c has been set to a space.
  866.     */
  867.    while (isspace(c) && s < end_s)
  868.       c = *s++;
  869.    if (!isspace(c))
  870.       return CvtFail;
  871.  
  872.    /*
  873.     * Test for integer.
  874.     */
  875.    if (!realflag && !scale && mantissa >= MinLong && mantissa <= MaxLong) {
  876.       result->integer = (msign == '+' ? lresult : -lresult);
  877.       return T_Integer;
  878.       }
  879.  
  880. #ifdef LargeInts
  881.    /*
  882.     * Test for bignum.
  883.     */
  884. #if COMPILER
  885.    if (largeints)
  886. #endif                    /* COMPILER */
  887.       if (!realflag) {
  888.          int rv;
  889.          rv = bigradix((int)msign, 10, ssave, end_s, result);
  890.          if (rv == Error)
  891.             fatalerr(0, NULL);
  892.          return rv;
  893.          }
  894. #endif                    /* LargeInts */
  895.  
  896.    if (!realflag)
  897.       return CvtFail;        /* don't promote to real if integer format */
  898.  
  899.    /*
  900.     * Rough tests for overflow and underflow.
  901.     */
  902.    if (sdigits + scale > LogHuge)
  903.       return CvtFail;
  904.  
  905.    if (sdigits + scale < -LogHuge) {
  906.       result->real = 0.0;
  907.       return T_Real;
  908.       }
  909.  
  910.    /*
  911.     * Put the number together by multiplying the mantissa by 5^scale and
  912.     *  then using ldexp() to multiply by 2^scale.
  913.     */
  914.  
  915.    exponent = (scale > 0)? scale : -scale;
  916.    fiveto = 1.0;
  917.    power = 5.0;
  918.    for (;;) {
  919.       if (exponent & 01)
  920.      fiveto *= power;
  921.       exponent >>= 1;
  922.       if (exponent == 0)
  923.      break;
  924.       power *= power;
  925.       }
  926.    if (scale > 0)
  927.       mantissa *= fiveto;
  928.    else
  929.       mantissa /= fiveto;
  930.  
  931.    err_no = 0;
  932.    mantissa = ldexp(mantissa, scale);
  933.    if (err_no > 0 && mantissa > 0)
  934.       /*
  935.        * ldexp caused overflow.
  936.        */
  937.       return CvtFail;
  938.  
  939.    if (msign == '-')
  940.       mantissa = -mantissa;
  941.    result->real = mantissa;
  942.    return T_Real;
  943.    }
  944.  
  945. #if COMPILER || !(defined LargeInts)
  946. /*
  947.  * radix - convert string s in radix r into an integer in *result.  sign
  948.  *  will be either '+' or '-'.
  949.  */
  950. int radix(sign, r, s, end_s, result)
  951. int sign;
  952. register int r;
  953. register char *s;
  954. register char *end_s;
  955. union numeric *result;
  956.    {
  957.    register int c;
  958.    long num;
  959.  
  960.    if (r < 2 || r > 36)
  961.       return CvtFail;
  962.    c = (s < end_s) ? *s++ : ' ';
  963.    num = 0L;
  964.    while (isalnum(c)) {
  965.       c = tonum(c);
  966.       if (c >= r)
  967.      return CvtFail;
  968.       num = num * r + c;
  969.       c = (s < end_s) ? *s++ : ' ';
  970.       }
  971.  
  972.    /*
  973.     * Skip trailing white space and make sure there is nothing else left
  974.     *  in the string. Note, if we have already reached end-of-string,
  975.     *  c has been set to a space.
  976.     */
  977.    while (isspace(c) && s < end_s)
  978.       c = *s++;
  979.    if (!isspace(c))
  980.       return CvtFail;
  981.  
  982.    result->integer = (sign == '+' ? num : -num);
  983.  
  984.    return T_Integer;
  985.    }
  986. #endif                    /* COMPILER || !(defined LargeInts) */
  987.  
  988.  
  989. /*
  990.  * cvpos - convert position to strictly positive position
  991.  *  given length.
  992.  */
  993.  
  994. word cvpos(pos, len)
  995. long pos;
  996. register long len;
  997.    {
  998.    register word p;
  999.  
  1000.    /*
  1001.     * Make sure the position is in the range of an int. (?)
  1002.     */
  1003.    if ((long)(p = pos) != pos)
  1004.       return CvtFail;
  1005.    /*
  1006.     * Make sure the position is within range.
  1007.     */
  1008.    if (p < -len || p > len + 1)
  1009.       return CvtFail;
  1010.    /*
  1011.     * If the position is greater than zero, just return it.  Otherwise,
  1012.     *  convert the zero/negative position.
  1013.     */
  1014.    if (pos > 0)
  1015.       return p;
  1016.    return (len + p + 1);
  1017.    }
  1018.  
  1019. /*
  1020.  * rtos - convert the real number n into a string using s as a buffer and
  1021.  *  making a descriptor for the resulting string.
  1022.  */
  1023. novalue rtos(n, dp, s)
  1024. double n;
  1025. dptr dp;
  1026. char *s;
  1027.    {
  1028.  
  1029.    s++;             /* leave room for leading zero */
  1030. /*
  1031.  * The following code is operating-system dependent [@rconv.01]. Convert real
  1032.  *  number to string.
  1033.  *
  1034.  * If IconGcvt is defined, icon_gcvt() is actually called, due to a #define
  1035.  *  in config.h.
  1036.  */
  1037.  
  1038. #if PORT
  1039.    gcvt(n, Precision, s);
  1040. Deliberate Syntax Error
  1041. #endif                    /* PORT */
  1042.  
  1043. #if HIGHC_386
  1044.    sprintf(s,"%.*g", Precision, n);
  1045. #else                    /* HIGHC_386 */
  1046. #if AMIGA || ARM || ATARI_ST || MSDOS || OS2 || UNIX || VMS
  1047.    gcvt(n, Precision, s);
  1048. #endif                                  /* AMIGA || ARM || ATARI_ST || ... */
  1049. #endif                    /* HIGHC_386 */
  1050.  
  1051. #if MACINTOSH
  1052.    sprintf(s,"%.20g",n);
  1053. #endif                    /* MACINTOSH */
  1054.  
  1055. #if VM || MVS
  1056.    sprintf(s,"%.*g", Precision, n);
  1057.    {
  1058.      char *ep = strstr(s, "e+");
  1059.      if (ep) memmove(ep+1, ep+2, strlen(ep+2)+1);
  1060.    }
  1061. #endif                    /* VM || MVS */
  1062.  
  1063. /*
  1064.  * End of operating-system specific code.
  1065.  */
  1066.    
  1067.    /*
  1068.     * Now clean up possible messes.
  1069.     */
  1070.    while (*s == ' ')            /* delete leading blanks */
  1071.       s++;
  1072.    if (*s == '.') {            /* prefix 0 to initial period */
  1073.       s--;
  1074.       *s = '0';
  1075.       }
  1076.    else if (strcmp(s, "-0.0") == 0)    /* negative zero */
  1077.       s++;
  1078.    else if (!index(s, '.') && !index(s,'e') && !index(s,'E'))
  1079.          strcat(s, ".0");        /* if no decimal point or exp. */
  1080.    if (s[strlen(s) - 1] == '.')        /* if decimal point is at the end ... */
  1081.       strcat(s, "0");
  1082.    StrLen(*dp) = strlen(s);
  1083.    StrLoc(*dp) = s;
  1084.    }
  1085.  
  1086. /*
  1087.  * cstos - convert the cset bit array pointed at by cs into a string using
  1088.  *  s as a buffer and making a descriptor for the resulting string.
  1089.  */
  1090.  
  1091. static novalue cstos(cs, dp, s)
  1092. int *cs;
  1093. dptr dp;
  1094. char *s;
  1095.    {
  1096.    register unsigned int w;
  1097.    register int j, i;
  1098.    register char *p;
  1099.  
  1100.    p = s;
  1101.    for (i = 0; i < CsetSize; i++) {
  1102.       if (cs[i])
  1103.      for (j=i*IntBits, w=cs[i]; w; j++, w >>= 1)
  1104.         if (w & 01)
  1105.            *p++ = FromAscii((char)j);
  1106.       }
  1107.    *p = '\0';
  1108.  
  1109.    StrLen(*dp) = p - s;
  1110.    StrLoc(*dp) = s;
  1111.    }
  1112.